VERSION 5.00
Object = "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}#1.1#0"; "SHDOCVW.dll"
Object = "{48E59290-9880-11CF-9754-00AA00C00908}#1.0#0"; "MSINET.OCX"
Begin VB.Form frmInputURL 
   BorderStyle     =   4  'Fixed ToolWindow
   Caption         =   "Input URL"
   ClientHeight    =   8325
   ClientLeft      =   45
   ClientTop       =   315
   ClientWidth     =   9630
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MDIChild        =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   8325
   ScaleWidth      =   9630
   ShowInTaskbar   =   0   'False
   Begin VB.CommandButton Command3 
      Caption         =   "QLD"
      Height          =   495
      Left            =   4920
      TabIndex        =   14
      Top             =   7680
      Width           =   1455
   End
   Begin VB.CommandButton Command2 
      Caption         =   "Sydney"
      Height          =   495
      Left            =   6360
      TabIndex        =   13
      Top             =   7680
      Width           =   1455
   End
   Begin VB.CommandButton cmdChina 
      Caption         =   "China"
      Height          =   495
      Left            =   3600
      TabIndex        =   12
      Top             =   7680
      Width           =   1335
   End
   Begin VB.TextBox txtItems 
      Height          =   615
      Left            =   5640
      TabIndex        =   10
      Text            =   "1000"
      Top             =   6720
      Width           =   3375
   End
   Begin SHDocVwCtl.WebBrowser brwWebBrowser 
      Height          =   4695
      Left            =   240
      TabIndex        =   7
      Top             =   1920
      Width           =   9015
      ExtentX         =   15901
      ExtentY         =   8281
      ViewMode        =   0
      Offline         =   0
      Silent          =   0
      RegisterAsBrowser=   0
      RegisterAsDropTarget=   1
      AutoArrange     =   0   'False
      NoClientEdge    =   0   'False
      AlignLeft       =   0   'False
      NoWebView       =   0   'False
      HideFileNames   =   0   'False
      SingleClick     =   0   'False
      SingleSelection =   0   'False
      NoFolders       =   0   'False
      Transparent     =   0   'False
      ViewID          =   "{0057D0E0-3573-11CF-AE69-08002B2E1262}"
      Location        =   "http:///"
   End
   Begin VB.CommandButton cmdBrowser 
      Caption         =   "Enlarge Browser"
      Height          =   495
      Left            =   360
      TabIndex        =   6
      Top             =   7680
      Width           =   1455
   End
   Begin VB.ComboBox cmbList 
      Height          =   315
      Left            =   360
      TabIndex        =   5
      Text            =   "Combo1"
      Top             =   1320
      Width           =   3255
   End
   Begin VB.CommandButton cmdAll 
      Caption         =   "Melbourne"
      Height          =   495
      Left            =   7800
      TabIndex        =   4
      Top             =   7680
      Width           =   1455
   End
   Begin VB.TextBox txtHTML 
      Appearance      =   0  'Flat
      Height          =   285
      Left            =   360
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   3
      Top             =   7320
      Visible         =   0   'False
      Width           =   8895
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Download HTML"
      Height          =   495
      Left            =   7800
      TabIndex        =   2
      Top             =   1080
      Width           =   1455
   End
   Begin VB.TextBox txtList 
      Appearance      =   0  'Flat
      Height          =   495
      Left            =   1680
      TabIndex        =   1
      Top             =   0
      Width           =   7575
   End
   Begin InetCtlsObjects.Inet Inet1 
      Left            =   0
      Top             =   0
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
   End
   Begin VB.Label lblNum 
      Height          =   375
      Left            =   360
      TabIndex        =   15
      Top             =   600
      Width           =   8055
   End
   Begin VB.Label Label2 
      Caption         =   "How many items you wanna download from yp?"
      Height          =   735
      Left            =   3120
      TabIndex        =   11
      Top             =   6720
      Width           =   2175
   End
   Begin VB.Label lblNow 
      Height          =   615
      Left            =   6240
      TabIndex        =   9
      Top             =   1200
      Width           =   1455
   End
   Begin VB.Label lblsum 
      Height          =   375
      Left            =   3960
      TabIndex        =   8
      Top             =   1320
      Width           =   2055
   End
   Begin VB.Label Label1 
      Caption         =   "List window:"
      Height          =   375
      Left            =   240
      TabIndex        =   0
      Top             =   120
      Width           =   1215
   End
End
Attribute VB_Name = "frmInputURL"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim sURLarr(0 To MAX_URL_ONE_PAGE) As String
Dim sURLCity(0 To MAX_URL_ONE_PAGE) As Integer
Const YELLOW_PAGE_URL As String = "http://www.yellowpages.com.au"

Public bExtractAll As Boolean

Dim yp As YellowPage
Dim iurlindex As Long

Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset

Dim rsTmp As New ADODB.Recordset
Dim rsDb As New ADODB.Recordset
Dim rsClass As New ADODB.Recordset
Dim CityArr(10) As Integer   'all city string which are entries...
Dim CityLink(10) As String   'all city links...

Dim iCityButton As Integer
Private Sub clr_url_arr()
    Dim i As Integer
    For i = 0 To MAX_URL_ONE_PAGE
        sURLarr(i) = ""
        sURLCity(i) = 0 'Australia
    Next i
End Sub

Private Sub cmbList_Change()
   cmbList_Click
End Sub

Private Sub cmbList_Click()
    Dim i, iResult As Integer
    i = cmbList.ListIndex
    If (sURLarr(i) <> "") Then
        iResult = InStr(LCase(sURLarr(i)), "http")
        If iResult = 0 Then
            MsgBox "The URL you input is illeagal, please try it again", vbOKOnly, SOFT_TITLE
            Exit Sub
        Else
            txtHTML.Text = GetWebHTML(sURLarr(i))
            brwWebBrowser.Navigate sURLarr(i)
        End If
    End If
End Sub

Private Sub GetData_FromYP(ByVal sql_input As String)
    
    Dim i As Integer
    Dim rsUpdate As New ADODB.Recordset
    Dim StartId As Long
    Dim EndId As Long
    Dim sRecords As String
    Dim iRecords As Long
    
    'Unload frmMsg
    
    StartId = 0
    EndId = 0
    i = 0
    'frmSplash.Show
    DoEvents
    bExtractAll = True
    cmdAll.Enabled = False
    cmdChina.Enabled = False
    
    'Me.AutoRedraw = True
    'how many data you wanna get
    'sRecords = InputBox("How many records you wanna download this time? Recommond between 100~ 1000!", SOFT_TITLE, 1000)
     
    'If sRecords = "" Then
    '    Exit Sub
    'End If
    
    iRecords = val(Trim(txtItems.Text))
    
    sql = "SELECT MAX(temp_userid) FROM org_firststep"
    CloseRecordSet rs
    OperateDatabase rs, cn, sql
    StartId = val(rs.Fields(0).value) + 1
    
    SaveIDArray2File Now & " Start From: " & str(StartId)
    
    sql = sql_input
    CloseRecordSet rs
    OperateDatabase rs, cn, sql
    While Not rs.EOF
        Dim city_id As Integer
        Dim link As String
        Dim subClass As String
        Dim iId As Long
        iId = rs.Fields(0).value
        city_id = rs.Fields(1).value
        link = rs.Fields(2).value
        subClass = rs.Fields(3).value
        
    'While sURLarr(i) <> ""
        txtHTML.Text = ""
        brwWebBrowser.Navigate link
        txtHTML.Text = GetWebHTML(link)
        While brwWebBrowser.Busy Or (brwWebBrowser.readyState <> READYSTATE_COMPLETE)
      '      frmSplash.lblStatus.Caption = "You are waiting for downloading this page..."
            DoEvents
        Wend
        'cmdOne_Click
        'Liang Fan changed on 27/2/2012
        'it is not necessary saved data into XML, just save it to database directly
        Call AnalyseDetailsPage(txtHTML.Text) 'all valid data saved to structure YP
        'default goto SA
       ' frmSplash.lblStatus.Caption = "You are analysing " & yp.NAME
        lblNum.Caption = " Business name is " & yp.NAME
        lblNow.Caption = " Now is: " & i
        lblsum.Caption = val(lblsum.Caption) + 1
        DoEvents
        yp.city = city_id
        yp.Second_Sort = subClass
        
        If Len(subClass) > 4 Then
            yp.first_sort = val(Mid(subClass, 1, 2))
        Else
            yp.first_sort = val(Mid(subClass, 1, 1))
        End If
        SaveToDBQuick yp, EndId
        SaveIDArray2File Now & "Business ID in our database is: " & str(EndId)
        
        
        'update the field -> done
        sql = "UPDATE `tmpyp` SET `done` = 1 WHERE ID = " & iId
        'rsUpdate
        CloseRecordSet rsUpdate
        OperateDatabase rsUpdate, cn, sql
        i = i + 1
        rs.MoveNext
        If lblNum.Caption = "1000" Then
            MsgBox "Reach 1000 Records, please stop downloading", vbOKOnly, SOFT_TITLE
            Exit Sub
        End If
    Wend
    DoEvents
    'Unload frmSplash
    
    
    'MsgBox "All done!", vbOKOnly, SOFT_TITLE
    cmdAll.Enabled = True
    cmdChina.Enabled = True
    frmMsg.Show
End Sub

Public Sub cmdAll_Click()
    Dim sqlSub, sql As String
    Dim iRecords As Long
    Dim rsRecords As New ADODB.Recordset
    Dim rsNums As New ADODB.Recordset
    iCityButton = 4
    iRecords = val(Trim(txtItems.Text))
    MsgBox "You are going to download " & iRecords & " records", vbOKOnly, SOFT_TITLE
    'how many subclasses I am going to download
    iTimes = iRecords / 100 + 1
    Call Cn2Oversea(cn)
    sqlSub = "SELECT * FROM `tmpyp` where done=0 GROUP by subClass"
    CloseRecordSet rsClass
    OperateDatabase rsClass, cn, sqlSub
    
    While Not rsClass.EOF
        sql = "SELECT count(*) from `tmpyp` where done=1 and subClass='" & rsClass.Fields(3).value & "'"
        CloseRecordSet rsRecords
        OperateDatabase rsRecords, cn, sql
        
        If rsRecords.Fields(0).value < DOWN_RECORDS Then
          '  sql = "SELECT count(*) from `tmpyp` where done=1 and subClass='" & rsClass.Fields(3).value & "'"
          '  CloseRecordSet rsRecords
          '  OperateDatabase rsRecords, cn, sql

          '  If rsRecords.Fields(0).value > 0 Then
            sql = "SELECT * FROM `tmpyp` WHERE subClass='" & rsClass.Fields(3).value & "' and `done` = 0 and `city` = 7  LIMIT 0, 50"
            
            GetData_FromYP sql
            
            iTimes = iTimes - 1
            If iTimes = 0 Then
             Exit Sub
            End If
           ' End If
        End If
        
        rsClass.MoveNext
    Wend
    
    MsgBox "All Done!", vbOKOnly, SOFT_TITLE
    cn.Close
End Sub
'save all id to file system for recording purpose
Private Sub SaveIDArray2File(ByVal str As String)
    Open "yp_log.txt" For Append As #5
    Print #5, str
    Close #5
End Sub

Private Sub SaveToDBQuick(yp As YellowPage, ByRef id As Long)

    Dim sql As String
    'save data to database org_firststep & org_details.
    '---------------------------
    'get an ID
    sql = "SELECT MAX(temp_userid) FROM org_firststep"
    CloseRecordSet rsDb
    OperateDatabase rsDb, cn, sql
    max_id = val(rsDb.Fields(0).value) + 1
    
    'added by Liang fan on 17/3/2012 -different button started from different segments
    Select Case iCityButton
        Case 1:
        If max_id <= 750000 Then
            max_id = 750000
        End If
        Case 2:
        'for QLD
        If max_id <= 550000 Then
            max_id = 550000
        End If
        Case 3:
        'for sydney
        If max_id <= 339699 Then
            max_id = 339699
        End If
        Case 4:
        'for melbourne
        If max_id <= 139699 Then
            max_id = 139700
        End If
    End Select
    
    id = max_id
    
    Dim full_id As String
'formatn(details.temp_userId, 8, strlen(details.temp_userId));
    full_id = "1110000" & yp.city & formatn(Trim(str(max_id)), 8)
    
    '-----if current routine is used by YP, then save data to local folder
    'download logo and brand package
    'put this first that is because yp.logo will be changed soon
    Call DownloadPics(str(max_id), full_id, yp.logo, yp.BRAND_P)
    
    yp.logo = str(max_id) & ".jpg"
    
sql = "INSERT INTO `org_details`(`usr_id`, `temp_userid`, `curr_addr`, `fax`, `website`, `thirdpart_upload`, `recorder`, `slang`, `self_intro`, `usr_face`, `usr_mails`, `usr_phone`, `usr_im`, `online_status`,`usr_shw_name`,  `sort_id`, `city_id`, `TradingHrs`) VALUES ('" & full_id & "'," & val(max_id) & ", '" & _
AddSlashes(Trim(yp.ADDRESS)) & "', '" & Trim(yp.fax) & "', '" & Trim(yp.website) & "', 1, 1, '" & _
AddSlashes(Trim(yp.SLOGAN)) & "', '" & AddSlashes(Trim(yp.des)) & "', '" & Trim(yp.logo) & "', '" & AddSlashes(yp.email) & "', '" & _
Trim(yp.tel) & "', '" & Trim(AddSlashes(yp.email)) & "', 1,'" & AddSlashes(Trim(yp.NAME)) & _
"', " & yp.first_sort & ", " & yp.city & ", '" & yp.HRS & "')"
Call CloseRecordSet(rsDb)
OperateDatabase rsDb, cn, sql


'INSERT INTO `org_firststep`(`temp_userid`, `org_name`, `emailadd`, `tel`, `org_type`, `user_pswd`, `city_id`,
'`curr_add`, `act_pin`, `acc_status`, `date_time`, `last_log_in`) VALUES ([value-1],[value-2],[value-3],[value-4],[value-5],[value-6],[value-7],[value-8],[value-9],[value-10],[value-11],[value-12])
sql = "INSERT INTO `org_firststep`(`temp_userid`, `org_name`, `emailadd`, `tel`, `org_type`, `user_pswd`, `city_id`, `curr_add`, `act_pin`, `acc_status`) VALUES (" & val(max_id) & _
", '" & AddSlashes(Trim(yp.NAME)) & "', '" & Trim(AddSlashes(yp.email)) & "', '" & Trim(yp.tel) & "', 1, 'e10adc3949ba59abbe56e057f20f883e', " & _
yp.city & ", '" & AddSlashes(Trim(yp.ADDRESS)) & "', '0', 1 )"
Call CloseRecordSet(rsDb)
OperateDatabase rsDb, cn, sql

'save classification
sql = "INSERT INTO `cs_classification`(`temp_userid`, `FirstLevel`, `SecondLevel`) VALUES (" & val(max_id) & "," & yp.first_sort & "," & yp.Second_Sort & ")"
Call CloseRecordSet(rsDb)
OperateDatabase rsDb, cn, sql

End Sub

Private Function DownloadPics(ByVal temp_id As String, ByVal full_id As String, ByVal slogo As String, ByVal sbrand As String)
    Dim sFolderPath As String
    sFolderPath = App.Path & "/" & full_id
    If Dir(sFolderPath, vbDirectory) = "" Then
        MkDir (sFolderPath)
    End If
    
    If slogo <> "" Then
        downFile Inet1, slogo, sFolderPath & "/" & temp_id & ".jpg"
    End If
    
    If sbrand <> "" Then
        downFile Inet1, sbrand, sFolderPath & "/brand.jpg"
    End If
End Function

Function downFile(Inet1 As Inet, URL As String, dest As String) As Boolean
On Error GoTo er1
        Dim bytes() As Byte
        bytes() = Inet1.OpenURL(URL, icByteArray)
        Dim tempS
        Open dest For Binary Access Write As #2
                Put #2, , bytes()
        Close #2
        downFile = True
        Exit Function
er1:
MsgBox err.Description
downFile = False
End Function


Private Sub CloseRecordSet(ByRef rs As ADODB.Recordset)
On Error GoTo NoErr
        rs.Close
NoErr:
End Sub

Private Sub cmdBrowser_Click()
    Load frmBrowser
    If Trim(txtDetails.Text) = "" Then
        frmBrowser.cboAddress.Text = sURLarr(cmbList.ListIndex)
    Else
        frmBrowser.cboAddress.Text = Trim(txtDetails.Text)
    End If
    frmBrowser.brwWebBrowser.Navigate frmBrowser.cboAddress.Text
    frmBrowser.Show
End Sub


Public Sub ShowXMLData()
    Call AnalyseDetailsPage(txtHTML.Text)
    FillInXML
End Sub


Private Sub FillInXML()
    Dim str As String
    str = ""
    If yp.URL <> "" Then
        str = str & "<URL>" & yp.URL & "</URL>" & vbCrLf
    End If
    If yp.NAME <> "" Then
        str = str & "<Name>" & yp.NAME & "</Name>" & vbCrLf
    End If
    If yp.ADDRESS <> "" Then
        str = str & "<Add>" & yp.ADDRESS & "</Add>" & vbCrLf
    End If
    If yp.BRAND_P <> "" Then
        str = str & "<Brand>" & yp.BRAND_P & "</Brand>" & vbCrLf
    End If
    If yp.des <> "" Then
        str = str & "<Des>" & yp.des & "</Des>" & vbCrLf
    End If
    If yp.email <> "" Then
        str = str & "<Email>" & yp.email & "</Email>" & vbCrLf
    End If
    If yp.fax <> "" Then
        str = str & "<Fax>" & yp.fax & "</Fax>" & vbCrLf
    End If
    If yp.HRS <> "" Then
        str = str & "<Hrs>" & yp.HRS & "</Hrs>" & vbCrLf
    End If
    If yp.logo <> "" Then
        str = str & "<Logo>" & yp.logo & "</Logo>" & vbCrLf
    End If
    If yp.SLOGAN <> "" Then
        str = str & "<Slogan>" & yp.SLOGAN & "</Slogan>" & vbCrLf
    End If
    If yp.tel <> "" Then
        str = str & "<Tel>" & yp.tel & "</Tel>" & vbCrLf
    End If
    If yp.website <> "" Then
        str = str & "<Website>" & yp.website & "</Website>" & vbCrLf
    End If
    frmDetailsData.txtXML.Text = Trim(str)
    
End Sub


Private Function InputAFile(ByVal File) As String
    Open File For Input As #1
    Do Until EOF(1)
        Line Input #1, i
        DoEvents
        InputAFile = InputAFile & i & vbCrLf
    Loop
    'If Right(InputAFile, 2) = vbCrLf Then
     '   InputAFile = Left(InputAFile, Len(InputAFile) - 2)
    'End If
    Close #1
End Function


Private Sub cmdChina_Click()
    Dim sqlSub, sql As String
    Dim iRecords As Long
    Dim rsRecords As New ADODB.Recordset
    Dim rsNums As New ADODB.Recordset
    iCityButton = 1
    
    iRecords = val(Trim(txtItems.Text))
    MsgBox "You are going to download " & iRecords & " records", vbOKOnly, SOFT_TITLE
    'how many subclasses I am going to download
    iTimes = iRecords / 100 + 1
    Call Cn2Oversea(cn)
    sqlSub = "SELECT * FROM `tmpyp` where done=0 GROUP by subClass"
    CloseRecordSet rsClass
    OperateDatabase rsClass, cn, sqlSub
    
    While Not rsClass.EOF
        sql = "SELECT count(*) from `tmpyp` where done=1 and subClass='" & rsClass.Fields(3).value & "'"
        CloseRecordSet rsRecords
        OperateDatabase rsRecords, cn, sql
        
        If rsRecords.Fields(0).value < DOWN_RECORDS Then
            'sql = "SELECT count(1) FROM `tmpyp` WHERE subClass='" & rsClass.Fields(3).value & "' and `done` = 0 and `city` <> 2 and `city` <> 7 and `city`<> 4 order by `city` DESC "
            'CloseRecordSet rsNums
            'OperateDatabase rsNums, cn, sql
            'If rsNums.Fields(0).value > 0 Then
                sql = "SELECT * FROM `tmpyp` WHERE subClass='" & rsClass.Fields(3).value & "' and `done` = 0 and `city` <> 2 and `city` <> 7 and `city`<> 4 order by `city` DESC LIMIT 0, 50"
                Debug.Print rsClass.Fields(3).value
                GetData_FromYP sql
                
                iTimes = iTimes - 1
                If iTimes = 0 Then
                 Exit Sub
                End If
            'End If
        End If
        
        rsClass.MoveNext
    Wend
    
    MsgBox "All Done!", vbOKOnly, SOFT_TITLE
    cn.Close
End Sub

'download all catelogs from yellowpage
Private Sub Command1_Click()
    'see if it got next page
    Dim iPages As Integer
    'index of pages
    Dim iIndex, iTimes As Integer
    
    Dim sURL, Second_Sort As String
    Dim bList As Boolean
    Dim iResult As Integer
    
    Dim sFeed As String
    
    MsgBox "You are going to download data base on `base.txt`", vbOKOnly, SOFT_TITLE
    Open "base.txt" For Input As #8
    Do Until EOF(8)
        Dim ArrDetails() As String
        Line Input #8, sFeed
        iTimes = 0
        ArrDetails = Split(sFeed, ",")
        iSecond_Sort = val(ArrDetails(1))
        bList = True
        iResult = 0
        
        yp.URL = ArrDetails(0)
        sURL = yp.URL
    
        iResult = InStr(LCase(sURL), "http")
        If iResult = 0 Then
            MsgBox "The URL you input is illeagal, please try it again", vbOKOnly, SOFT_TITLE
            Exit Sub
        Else
            Dim iCityNumber As Integer
            iCityNumber = 0
            'get all data from a particular city
            Call GetCityFromYP(sURL, CityArr, CityLink)
            
            
                Dim sHTML As String
                If bList Then
                    frmSplash.Show
                    frmSplash.lblStatus.Caption = "Fetching all categories in all cities..."
                    DoEvents
                    While CityArr(iCityNumber) <> 0
                        iPages = 1
                        iIndex = 1
                        'get the first page
                        Do While iPages <> 0
                            sHTML = GetWebHTML(CityLink(iCityNumber))
                            Call FullfillList(sHTML, CityArr(iCityNumber))
                            
                            iIndex = iIndex + 1
                            iPages = GetNextPage(sHTML, iIndex, CityLink(iCityNumber))
                            'for testing
                            'If iIndex > 2 Then
                            '    GoTo TestTmpJump
                            'End If
                        Loop
                        iCityNumber = iCityNumber + 1
                    Wend
                    'cmbList.ListIndex = 0
                    DoEvents
                    Unload frmSplash
                    'MsgBox "Download finished!", vbOKOnly, SOFT_TITLE
                Else
                    txtHTML.Text = GetWebHTML(sURL)
                    brwWebBrowser.Navigate sURL
                    While brwWebBrowser.Busy Or (brwWebBrowser.readyState <> READYSTATE_COMPLETE)
                    DoEvents
                    Wend
                End If
            
        End If
    Loop
    Close #8
End Sub

'get the heading information link divided by different cities
Private Sub GetCityFromYP(ByVal sURL As String, ByRef CityArr() As Integer, ByRef CityLink() As String)
    Dim sHTML As String
    Dim iIndex, iEnd, iEndCity, i As Integer
    
    i = 0
    sHTML = GetWebHTML(sURL)
    'look for citylist
    iIndex = InStr(1, sHTML, "citylist")
    If iIndex <> 0 Then
        'looking for a link
        While 1
        iIndex = InStr(iIndex + 8, sHTML, "<a href=")
        If iIndex <> 0 Then
            iEnd = InStr(iIndex, sHTML, ">")
            CityLink(i) = Mid(sHTML, iIndex + 9, iEnd - iIndex - 10)
        End If
        
        'looking for a city name
        iEndCity = InStr(iEnd, sHTML, "<")
        CityArr(i) = GetCityID(Mid(sHTML, iEnd + 1, iEndCity - iEnd - 1))
        If CityArr(i) = 1 Then
            Exit Sub
        End If
        'just for the first time -testing purpose
        'If CityArr(i) <> 2 Then
            i = i + 1
        'End If
        Wend
    End If
End Sub

Private Function GetCityID(ByVal str As String) As Integer
    If str = "Sydney" Then
        GetCityID = 2
        Exit Function
    End If
    
    If str = "Melbourne" Then
        GetCityID = 7
        Exit Function
    End If
    
    If str = "Brisbane" Then
        GetCityID = 4
        Exit Function
    End If
    
    If str = "Hobart" Then
        GetCityID = 6
        Exit Function
    End If
    
    If str = "Perth" Then
        GetCityID = 8
        Exit Function
    End If
    
    If str = "Darwin" Then
        GetCityID = 3
        Exit Function
    End If
    
    If str = "Canberra" Then
        GetCityID = 1
        Exit Function
    End If
    
    If str = "Adelaide" Then
        GetCityID = 5
        Exit Function
    End If
End Function


'scan html see if there are 'page_number_2', 'page_number_3', 'page_number_4'...
Private Function GetNextPage(ByVal sHTML As String, ByVal i As Integer, ByRef sURL As String) As Integer
    Dim iIndex As Long
    Dim iEnd As Long
    iIndex = InStr(1, sHTML, "page_number_" & i)
    If iIndex = 0 Then
        'did not find it
        GetNextPage = 0
        Exit Function
    Else
        'get this tag
        iIndex = InStr(iIndex, sHTML, "<a href=")
        iEnd = InStr(iIndex, sHTML, "class")
        sURL = Mid(sHTML, iIndex + 9, iEnd - iIndex - 11)
        sURL = YELLOW_PAGE_URL & sURL
        'Debug.Print sURL
        GetNextPage = i
    End If
End Function

Private Sub Command2_Click()
       Dim sqlSub, sql As String
    Dim iRecords As Long
    Dim rsRecords As New ADODB.Recordset
    Dim rsNums As New ADODB.Recordset
    iCityButton = 3
    iRecords = val(Trim(txtItems.Text))
    MsgBox "You are going to download " & iRecords & " records", vbOKOnly, SOFT_TITLE
    'how many subclasses I am going to download
    iTimes = iRecords / 100 + 1
    Call Cn2Oversea(cn)
    sqlSub = "SELECT * FROM `tmpyp` where done=0 GROUP by subClass"
    CloseRecordSet rsClass
    OperateDatabase rsClass, cn, sqlSub
    
    While Not rsClass.EOF
        sql = "SELECT count(*) from `tmpyp` where done=1 and subClass='" & rsClass.Fields(3).value & "'"
        CloseRecordSet rsRecords
        OperateDatabase rsRecords, cn, sql
        
        If rsRecords.Fields(0).value < DOWN_RECORDS Then
            'sql = "SELECT count(*) from `tmpyp` where done=1 and subClass='" & rsClass.Fields(3).value & "'"
            'CloseRecordSet rsRecords
            'OperateDatabase rsRecords, cn, sql
            'If rsRecords.Fields(0).value < 100 Then
            sql = "SELECT * FROM `tmpyp` WHERE subClass='" & rsClass.Fields(3).value & "' and `done` = 0 and `city` = 2  LIMIT 0, 50"
            
            GetData_FromYP sql
            
            iTimes = iTimes - 1
            If iTimes = 0 Then
             Exit Sub
            End If
            'End If
        End If
        
        rsClass.MoveNext
    Wend
    
    MsgBox "All Done!", vbOKOnly, SOFT_TITLE
    cn.Close
End Sub

Private Sub Command3_Click()
    Dim sqlSub, sql As String
    Dim iRecords As Long
    Dim rsRecords As New ADODB.Recordset
    Dim rsNums As New ADODB.Recordset
    iCityButton = 2
    iRecords = val(Trim(txtItems.Text))
    MsgBox "You are going to download " & iRecords & " records", vbOKOnly, SOFT_TITLE
    'how many subclasses I am going to download
    iTimes = iRecords / 100 + 1
    Call Cn2Oversea(cn)
    sqlSub = "SELECT * FROM `tmpyp` where done=0 GROUP by subClass"
    CloseRecordSet rsClass
    OperateDatabase rsClass, cn, sqlSub
    
    While Not rsClass.EOF
        sql = "SELECT count(*) from `tmpyp` where done=1 and subClass='" & rsClass.Fields(3).value & "'"
        CloseRecordSet rsRecords
        OperateDatabase rsRecords, cn, sql
        
        If rsRecords.Fields(0).value < DOWN_RECORDS Then
            'sql = "SELECT count(*) from `tmpyp` where done=1 and subClass='" & rsClass.Fields(3).value & "'"
            'CloseRecordSet rsRecords
            'OperateDatabase rsRecords, cn, sql
            'If rsRecords.Fields(0).value > 0 Then
                sql = "SELECT * FROM `tmpyp` WHERE subClass='" & rsClass.Fields(3).value & "' and `done` = 0 and `city` = 4  LIMIT 0, 50"
                Debug.Print rsClass.Fields(3).value
                GetData_FromYP sql
                
                iTimes = iTimes - 1
                If iTimes = 0 Then
                 Exit Sub
                End If
            'End If
        End If
        
        rsClass.MoveNext
    Wend
    
    MsgBox "All Done!", vbOKOnly, SOFT_TITLE
    cn.Close
End Sub

Private Sub Form_Load()
    cmbList.Clear
    bExtractAll = False
    iurlindex = 0
    
    iCityButton = 0
End Sub

Public Function FullfillList(ByVal str As String, ByVal iCityId As Integer)
    Dim iIndex As Long
    Dim bStart, bEnd As Boolean
    Dim sURL As String
    Dim sBusName As String
    Dim tmpIndex As Long
    iIndex = 1
    tmpIndex = 1
    'cmbList.Clear
    'clr_url_arr
    'analyse the HTML file
    'search "listingName paragraph" for each single business
    iIndex = InStr(iIndex, str, "listingName paragraph")
    While iIndex <> 0
        Dim ch As String
        bStart = False
        bEnd = False
        iIndex = InStr(iIndex, str, "<a href=")
        sURL = ""
        '-----------get the url of business name-----------
        While Not bEnd
            ch = Mid(str, iIndex, 1)
            If ch = Chr(34) Then
                If Not bStart Then
                    bStart = True
                Else
                    If Not bEnd Then
                        bEnd = True
                    End If
                End If
            Else
                If bStart Then
                    sURL = sURL & ch
                End If
            End If
            
            iIndex = iIndex + 1
        Wend
        If (sURL <> "") Then
            'Modified by Liang on 4/3/2012
            'save to database tmpyp instead of putting it to memory
            Dim sql As String
            sql = "INSERT INTO `tmpyp`(`city`, `link`, `subclass`) VALUES (" & iCityId & ", '" & YELLOW_PAGE_URL & sURL & "', " & iSecond_Sort & ")"
            CloseRecordSet rsTmp
            OperateDatabase rsTmp, cn, sql
            'sURLarr(iurlindex) = YELLOW_PAGE_URL & sURL
            'Debug.Print sURLarr(iurlindex)
            'sURLCity(iurlindex) = iCityId
            'Debug.Print iCityId
            lblsum.Caption = "Total business number: " & iurlindex
            iurlindex = iurlindex + 1
            
            '-----------get the business name-----------
            sBusName = ""
            iIndex = InStr(iIndex, str, "<span id")
            bEnd = False
            While Not bEnd
                ch = Mid(str, iIndex, 1)
                If ch = ">" Then
                    tmpIndex = iIndex + 1
                    iIndex = InStr(iIndex, str, "</span>")
                    sBusName = Mid(str, tmpIndex, iIndex - tmpIndex)
                    'must have a name
                    If sBusName = "" Then
                        sBusName = "Unknown Error"
                    End If
                    'cmbList.AddItem sBusName
                    frmSplash.lblStatus.Caption = "Current business numbers: " & sBusName
                    DoEvents
                    bEnd = True
                End If
                iIndex = iIndex + 1
            Wend
            iIndex = InStr(iIndex, str, "listingName paragraph")
        End If
    Wend
End Function

Private Sub clrDetailsStructure()
    yp.ADDRESS = ""
    yp.BRAND_P = ""
    yp.des = ""
    yp.email = ""
    yp.fax = ""
    yp.HRS = ""
    yp.logo = ""
    yp.NAME = ""
    yp.SLOGAN = ""
    yp.tel = ""
    yp.website = ""
End Sub

Public Sub AnalyseDetailsPage(ByVal str As String)
        Dim i As Integer
        Dim bIsWeb As Boolean
        Dim bIsEmail, bIsFax, bIsPackage As Boolean
        bIsWeb = False
        bIsEmail = False
        bIsFax = False
        bIsPackage = False
        
        Dim sTag, sId, sClassName, sInnerTxt, sTitle As String
        sTag = ""
        sId = ""
        sClassName = ""
        sInnerTxt = ""
        sTitle = ""
        clrDetailsStructure
        
        For i = 0 To brwWebBrowser.Document.All.length - 1
            sTag = brwWebBrowser.Document.All(i).tagName
            sId = brwWebBrowser.Document.All(i).id
            sClassName = brwWebBrowser.Document.All(i).classname
            sInnerTxt = brwWebBrowser.Document.All(i).innertext
            sTitle = brwWebBrowser.Document.All(i).Title
            '------logo-----------
            If UCase(sTag) = UCase("img") And sId = "logoLinkImage" Then
                    yp.logo = brwWebBrowser.Document.All(i).href
            '------name-----------
            ElseIf UCase(sTag) = UCase("h1") And sClassName = "listingName" Then
                    yp.NAME = sInnerTxt
            '------slogan-----------
            ElseIf UCase(sTag) = UCase("h3") And sClassName = "textDesc" Then
                    yp.SLOGAN = sInnerTxt
            '------address-----------
            ElseIf UCase(sTag) = UCase("span") And sClassName = "listingAddressText" Then
                    yp.ADDRESS = sInnerTxt
            '------tel-----------
            ElseIf UCase(sTag) = UCase("span") And sId = "preferredContactNumber" Then
                    yp.tel = sInnerTxt
            '------website-----------
            ElseIf UCase(sTag) = UCase("img") And sClassName = "webAddressIcon" Then
                    bIsWeb = True
            ElseIf UCase(sTag) = UCase("span") And bIsWeb Then
                    yp.website = sInnerTxt
                    bIsWeb = False
            '------email-----------
            ElseIf UCase(sTag) = UCase("img") And sClassName = "emailAddressIcon" Then
                    bIsEmail = True
            ElseIf UCase(sTag) = UCase("span") And bIsEmail Then
                    yp.email = sInnerTxt
                    bIsEmail = False
            '-------opening hours-----------
            ElseIf UCase(sTag) = UCase("div") And sId = "Monday-content-am" Then
                    Call ParseHrs(sInnerTxt)
            ElseIf UCase(sTag) = UCase("div") And sId = "Tuesday-content-am" Then
                    Call ParseHrs(sInnerTxt)
            ElseIf UCase(sTag) = UCase("div") And sId = "Wednesday-content-am" Then
                    Call ParseHrs(sInnerTxt)
            ElseIf UCase(sTag) = UCase("div") And sId = "Thursday-content-am" Then
                    Call ParseHrs(sInnerTxt)
            ElseIf UCase(sTag) = UCase("div") And sId = "Friday-content-am" Then
                    Call ParseHrs(sInnerTxt)
            ElseIf UCase(sTag) = UCase("div") And sId = "Saturday-content-am" Then
                    Call ParseHrs(sInnerTxt)
            ElseIf UCase(sTag) = UCase("div") And sId = "Sunday-content-am" Then
                    Call ParseHrs(sInnerTxt)
                    If Right(yp.HRS, 1) = "|" Then
                        yp.HRS = Left(yp.HRS, Len(yp.HRS) - 1)
                    End If
            '-------Des-----------
            ElseIf UCase(sTag) = UCase("div") And sId = "about-us" And sClassName = "tab-contents" Then
                    yp.des = sInnerTxt
            '------Fax-----------
            ElseIf UCase(sTag) = UCase("span") And sClassName = "phoneContactText" And sTitle = "Fax number" Then
                    bIsFax = True
            ElseIf bIsFax And sClassName = "otherContactNumber" Then
                    yp.fax = sInnerTxt
                    bIsFax = False
            '------brand package-----------
            ElseIf sId = "bppBrandpackage" Then
                    bIsPackage = True
            ElseIf bIsPackage And UCase(sTag) = UCase("img") Then
                    yp.BRAND_P = brwWebBrowser.Document.All(i).href
                    bIsPackage = False
            End If
        Next i
End Sub


Private Sub ParseHrs(ByVal sInnerTxt As String)
    Dim sHrs As String
    Dim iPos As Integer
    iPos = 0
    sHrs = sInnerTxt
    If Trim(sHrs) = "-" Then
        yp.HRS = yp.HRS & "|" & "|"
        Exit Sub
    End If
    'such as "8:00 am to 9:00 pm"
    iPos = InStr(1, sInnerTxt, "to")
    If iPos <> 0 Then
        yp.HRS = yp.HRS & Trim(Mid(sHrs, 1, iPos - 1)) & "|" & Trim(Mid(sHrs, iPos + 2, Len(sHrs) - iPos - 2)) & "|"
    Else
        yp.HRS = yp.HRS & "|" & "|"
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error GoTo err:
    cn.Close
err:
    
End Sub

